home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / runtime / interp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-09-24  |  22.3 KB  |  897 lines  |  [TEXT/MPS ]
  1. /* The bytecode interpreter */
  2.  
  3. #include <math.h>
  4. #include "alloc.h"
  5. #include "debugger.h"
  6. #include "fail.h"
  7. #include "instruct.h"
  8. #include "memory.h"
  9. #include "misc.h"
  10. #include "mlvalues.h"
  11. #include "prims.h"
  12. #include "signals.h"
  13. #include "stacks.h"
  14. #include "str.h"
  15. #include "unalignd.h"
  16. #ifdef macintosh
  17. #include <CursorCtl.h>
  18. #endif
  19.  
  20. #ifdef DEBUG
  21. static long icount = 0;
  22. static void stop_here () {}
  23. #endif
  24.  
  25. /* Registers for the abstract machine */
  26.  
  27. /*    pc      the code pointer
  28.     asp      the stack pointer for the argument stack (grows downward)
  29.     rsp      the stack pointer for the return stack (grows downward)
  30.     tp      pointer to the current trap frame
  31.     env      the remanent part (heap-allocated) of the environment
  32.      cache_size the nymber of entries in the volatile part of the environment
  33.     accu      the accumulator
  34.  
  35. "asp" and "rsp" are local copies of the global variables
  36. "extern_asp" and "extern_rsp".
  37.  
  38. */
  39.  
  40. extern value global_data;
  41. extern code_t start_code;
  42.  
  43. /* Other viewpoints on rsp */
  44.  
  45. #define retsp  ((struct return_frame *) rsp)
  46. #define trapsp ((struct trap_frame   *) rsp)
  47.  
  48. #define push_ret_frame() \
  49.   (rsp = (value *) ((char *) rsp - sizeof(struct return_frame)))
  50. #define pop_ret_frame() \
  51.   (rsp = (value *) ((char *) rsp + sizeof(struct return_frame)))
  52. #define push_trap_frame() \
  53.   (rsp = (value *) ((char *) rsp - sizeof(struct trap_frame)))
  54. #define pop_trap_frame() \
  55.   (rsp = (value *) ((char *) rsp + sizeof(struct trap_frame)))
  56.  
  57. /* Other viewpoints on pc (to read immediate operands) */
  58.  
  59. #define SHORT  (sizeof(short))
  60. #define LONG   (sizeof(int32))
  61. #define DOUBLE (sizeof(double))
  62.  
  63. #define s16pc s16(pc)
  64. #define u16pc u16(pc)
  65. #define s32pc s32(pc)
  66. #define u32pc u32(pc)
  67.  
  68. /* The empty environment */
  69.  
  70. #define null_env Atom(0)
  71.  
  72. /* Code for returning from a signal handler */
  73.  
  74. unsigned char return_from_interrupt[] = { POP, RETURN };
  75.  
  76. /* To save and restore registers around GC calls */
  77.  
  78. #define Setup_for_gc                                 \
  79.   { push_ret_frame();                                 \
  80.     retsp->env = env;                                 \
  81.     retsp->cache_size = cache_size;                         \
  82.     *--asp = accu;                                 \
  83.     extern_asp = asp; extern_rsp = rsp;                         \
  84.   }
  85.  
  86. #define Restore_after_gc                             \
  87.   { accu = *asp++;                                 \
  88.     env = retsp->env;                                 \
  89.     pop_ret_frame ();                                 \
  90.   }
  91.  
  92. /* To save and restore registers around C primitive calls. */
  93.  
  94. #define Setup_for_c_call                                                     \
  95.   { push_ret_frame();                                                        \
  96.     retsp->env = env;                                                        \
  97.     retsp->cache_size = cache_size;                                          \
  98.     extern_asp = asp;                                                        \
  99.     extern_rsp = rsp;                                                        \
  100.   }
  101. #define Restore_after_c_call                                                 \
  102.   { asp = extern_asp;                                                        \
  103.     rsp = extern_rsp;                                                        \
  104.     env = retsp->env;                                                        \
  105.     pop_ret_frame();                                                         \
  106.   }
  107.  
  108. /* To heap-allocate the whole environment */
  109.  
  110. #define heapify_env()                                 \
  111. {                                         \
  112.   mlsize_t env_size = Wosize_val(env);                         \
  113.   mlsize_t new_size = env_size + cache_size;                     \
  114.   value * from, * to;                                 \
  115.                                          \
  116.   Alloc_small(tmp,  new_size, 0);                         \
  117.   for(to = Op_val(tmp); cache_size > 0; cache_size--) *to++ = *rsp++;         \
  118.   for(from = Op_val(env); env_size > 0; env_size--  ) *to++ = *from++;         \
  119.   env = tmp;                                     \
  120. }
  121.  
  122. /* GCC 2.0 has labels as first-class values. We take advantage of that
  123.    to provide faster dispatch than the "switch" statement. */
  124.  
  125. #if defined(__GNUC__) && __GNUC__ >= 2 && !defined(DEBUG)
  126. #define DIRECT_JUMP
  127. #endif
  128.  
  129. /* The interpreter itself */
  130.  
  131. value interprete(prog)
  132.      code_t prog;
  133. {
  134. /* Declarations for the registers of the abstract machine.
  135.    The most heavily used registers come first.
  136.    For reasonable performance, "pc" MUST reside in a register.
  137.    Many ``optimizing'' compilers underestimate the importance of "pc",
  138.    and don't put it in a register. 
  139.    For GCC users, I've hand-assigned registers for some architectures. */
  140.  
  141. #if defined(__GNUC__) && defined(mc68000)
  142.   register code_t pc asm("a5");
  143.   register value accu;
  144.   register value * asp;
  145.   register value * rsp;
  146. #else
  147. #if defined(__GNUC__) && defined(sparc)
  148.   register code_t pc asm("%l0");
  149.   register value accu asm("%l1");
  150.   register value * asp asm("%l2");
  151.   register value * rsp asm("%l3");
  152. #else
  153. #if defined(__GNUC__) && defined(i386)
  154. #if defined(MSDOS)
  155.   register code_t pc asm("si");
  156. #else
  157.   register code_t pc asm("%esi");
  158. #endif
  159.   register value accu;
  160.   register value * asp;
  161.   register value * rsp;
  162. #else
  163.   register code_t pc;
  164.   register value accu;
  165.   register value * asp;
  166.   register value * rsp;
  167. #endif
  168. #endif
  169. #endif
  170.   int cache_size;
  171.   value env;
  172.   value tmp;
  173.   struct longjmp_buffer * initial_external_raise;
  174.   int initial_rsp_offset;
  175.   value * initial_c_roots_head;
  176.   struct longjmp_buffer raise_buf;
  177.  
  178. #ifdef DIRECT_JUMP
  179.   static void * jumptable[] = {
  180. #   include "jumptbl.h"
  181.   };
  182. #endif
  183.  
  184.   asp = extern_asp;
  185.   rsp = extern_rsp;
  186.   pc = prog;
  187.   env = null_env;
  188.   cache_size = 0;
  189.   accu = Val_long(0);
  190.   initial_c_roots_head = c_roots_head;
  191.  
  192.   if (setjmp(raise_buf.buf)) {
  193.     c_roots_head = initial_c_roots_head;
  194.     accu = exn_bucket;
  195.     goto raise;
  196.   }
  197.   initial_external_raise = external_raise;
  198.   external_raise = &raise_buf;
  199.   initial_rsp_offset = (char *) ret_stack_high - (char *) rsp;
  200.  
  201. #ifdef DEBUG
  202.   log_ptr = log_buffer;
  203. #endif
  204.  
  205. #ifdef DIRECT_JUMP
  206. # define Instruct(name) lbl_##name
  207. # define Next goto *jumptable[*pc++]
  208. #else
  209. # define Instruct(name) case name
  210. # define Next break
  211. #endif
  212.  
  213. #ifdef DIRECT_JUMP
  214.   Next;                         /* Jump to the first instruction */
  215. #else
  216.   while (1) {
  217. #ifdef DEBUG
  218.     --icount;
  219.     if (icount == 0) stop_here ();
  220.     *log_ptr++ = pc;
  221.     if (log_ptr >= log_buffer + LOG_BUFFER_SIZE) log_ptr = log_buffer;
  222.     if (trace_flag) disasm_instr(pc);
  223.     Assert(asp >= arg_stack_low);
  224.     Assert(asp <= arg_stack_high);
  225.     Assert(rsp >= ret_stack_low);
  226.     Assert(rsp <= ret_stack_high);
  227. #endif
  228.     switch (*pc++) {
  229. #endif
  230.  
  231.     Instruct(STOP):
  232.       extern_asp = asp;
  233.       extern_rsp = rsp;
  234.       external_raise = initial_external_raise;
  235.       return accu;
  236.       
  237.     Instruct(CUR):
  238.       if (cache_size) heapify_env();
  239.       Alloc_small(accu, Closure_wosize, Closure_tag);
  240.       Env_val(accu) = env;
  241.       Code_val(accu) = pc + s16pc;
  242.       pc += SHORT;
  243.       Next;
  244.       
  245.     Instruct(APPLY):
  246.     apply:
  247.       push_ret_frame();
  248.       retsp->pc = pc;
  249.       retsp->env = env;
  250.       retsp->cache_size = cache_size;
  251.       *--rsp = *asp++;
  252.       cache_size = 1;
  253.       pc = Code_val(accu);
  254.       env = Env_val(accu);
  255.       goto check_stacks;
  256.       
  257.     Instruct(RETURN):
  258.       if (*asp == MARK) {
  259.     rsp += cache_size;
  260.     asp++;
  261.     pc = retsp->pc;
  262.     env = retsp->env;
  263.     cache_size = retsp->cache_size;
  264.     pop_ret_frame();
  265.     Next;
  266.       }
  267.       /* fall through APPTERM */
  268.  
  269.     Instruct(APPTERM):
  270.     appterm:
  271.       rsp += cache_size;
  272.       *--rsp = *asp++;
  273.       cache_size = 1;
  274.       pc = Code_val(accu);
  275.       env = Env_val(accu);
  276.  
  277.     check_stacks:
  278.       if (asp < arg_stack_threshold || rsp < ret_stack_threshold) {
  279.         Setup_for_gc;
  280.         realloc_stacks();
  281.         rsp = extern_rsp;
  282.         asp = extern_asp;
  283.         Restore_after_gc;
  284.       }
  285.       /* fall through CHECK_SIGNALS */
  286.  
  287.     Instruct(CHECK_SIGNALS):
  288. #ifdef macintosh
  289.       { static int spin_count = 1;
  290.         if (--spin_count == 0) { spin_count = 24; SpinCursor ((short) 1); }
  291.       }
  292. #endif
  293. #if defined(MSDOS) && defined(__GNUC__)
  294.       { static int poll_count = 1;
  295.         if (--poll_count == 0) { poll_count = 500; poll_break(); }
  296.       }
  297. #endif
  298.       if (signal_is_pending) goto process_signal;
  299.       Next;
  300.  
  301.     process_signal:
  302.       signal_is_pending = 0;
  303.       push_ret_frame();
  304.       retsp->pc = pc;
  305.       retsp->env = env;
  306.       retsp->cache_size = cache_size;
  307.       *--asp = MARK;
  308.       *--asp = accu;
  309.       *--asp = MARK;
  310.       env = Atom(0);
  311.       push_ret_frame();
  312.       retsp->pc = return_from_interrupt;
  313.       retsp->env = env;
  314.       retsp->cache_size = 0;
  315.       *--rsp = Val_int(signal_number);
  316.       cache_size = 1;
  317.       pc = signal_handler;
  318.       Next;
  319.  
  320.     Instruct(PUSH_GETGLOBAL_APPLY):
  321.       *--asp = accu;
  322.       accu = Field(global_data, u16pc);
  323.       pc += SHORT;
  324.       goto apply;
  325.  
  326.     Instruct(PUSH_GETGLOBAL_APPTERM):
  327.       *--asp = accu;
  328.       accu = Field(global_data, u16pc);
  329.       pc += SHORT;
  330.       goto appterm;
  331.  
  332.     Instruct(GRAB):
  333.       if (*asp != MARK) {
  334.     *--rsp = *asp++;
  335.     cache_size++;
  336.       } else {
  337.     if (cache_size) heapify_env();
  338.     Alloc_small(accu, Closure_wosize, Closure_tag);
  339.     Code_val(accu) = pc;
  340.     Env_val(accu) = env;
  341.     asp++;
  342.     pc = retsp->pc;
  343.     env = retsp->env;
  344.     cache_size = retsp->cache_size;
  345.     pop_ret_frame();
  346.       }
  347.       Next;
  348.       
  349. #define access(n) (cache_size > n ? rsp[n] : Field(env, n - cache_size))
  350. #define access0() (cache_size > 0 ? rsp[0] : Field(env,0))
  351.  
  352.     Instruct(ACC0):
  353.       accu = access0(); Next;
  354.     Instruct(ACC1):
  355.       accu = access(1); Next;
  356.     Instruct(ACC2):
  357.       accu = access(2); Next;
  358.     Instruct(ACC3):
  359.       accu = access(3); Next;
  360.     Instruct(ACC4):
  361.       accu = access(4); Next;
  362.     Instruct(ACC5):
  363.       accu = access(5); Next;
  364.     Instruct(ACCESS):
  365.       { int n = *pc++;
  366.     accu = access(n);
  367.     Next;
  368.       }
  369.       
  370.     Instruct(LET):
  371.       *--rsp = accu;
  372.       cache_size++;
  373.       Next;
  374.       
  375.     Instruct(DUMMY):
  376.       { int n = *pc++;
  377.     Assert (n > 0);
  378.     Alloc_small(accu, n, 0);
  379.     while (n--){
  380.       Field (accu, n) = Val_long (0);
  381.     }
  382.     Next;
  383.       }
  384.  
  385.     Instruct(UPDATE):
  386.       { mlsize_t n;
  387.         tmp = *asp++;
  388.         Tag_val (accu) = Tag_val (tmp);
  389.         for (n = 0; n < Wosize_val (tmp); n++) {
  390.           modify (&Field (accu, n), Field (tmp, n));
  391.         }
  392.         Next;
  393.       }
  394.  
  395.     Instruct(LETREC1):        /* Replaces Dummy 1; Cur lbl; Update 0 */
  396.       Alloc_small(accu, Closure_wosize, Closure_tag);
  397.       Field(accu,0) = Field(accu,1) = Atom(0);
  398.       *--rsp = accu;
  399.       cache_size++;
  400.       heapify_env();
  401.       Code_val(accu) = pc + s16pc;
  402.       Modify(&Env_val(accu), env);
  403.       pc += SHORT;
  404.       Next;
  405.       
  406.     Instruct(ENDLET1):
  407.       if (cache_size != 0) {
  408.     cache_size--; rsp++;
  409.       } else {
  410.     int i;
  411.     value * from;
  412.     i = Wosize_val(env);
  413.         from = &Field(env, i);
  414.         cache_size = i - 1;
  415.         for (i = cache_size; i > 0; i--) *--rsp = *--from;
  416.     env = null_env;
  417.       }
  418.       Next;
  419.       
  420.     Instruct(ENDLET):
  421.       { int n = *pc++;
  422.     if (cache_size >= n) {
  423.       cache_size -= n;
  424.       rsp += n;
  425.     } else {
  426.       int i;
  427.       value * from;
  428.       n -= cache_size;
  429.       rsp += cache_size;
  430.           i = Wosize_val(env);
  431.       cache_size = i - n;
  432.           from = &Field(env, i);
  433.       for (i = cache_size; i > 0; i--) *--rsp = *--from;
  434.       env = null_env;
  435.     }
  436.     Next;
  437.       }
  438.       
  439.     Instruct(PUSHTRAP):
  440.       { value * src = rsp + cache_size;
  441.     int i = cache_size;
  442.     
  443.     push_trap_frame();
  444.     trapsp->pc = pc + s16pc;
  445.     pc += SHORT;
  446.     trapsp->env = env;
  447.     trapsp->cache_size = cache_size + 2;
  448.     trapsp->asp = asp;
  449.     trapsp->tp = tp;
  450.     tp = trapsp;
  451.     while(i--) *--rsp = *--src;
  452.     *--asp = MARK;
  453.     Next;
  454.       }
  455.  
  456.     raise:            /* An external raise jumps here */
  457.  
  458.     Instruct(RAISE):
  459.       rsp = (value *) tp;
  460.       if (rsp >= (value *)((char *) ret_stack_high - initial_rsp_offset)) {
  461.         exn_bucket = accu;
  462.         external_raise = initial_external_raise;
  463.         longjmp(external_raise->buf, 1);
  464.       }
  465.       pc = trapsp->pc;
  466.       env = trapsp->env;
  467.       cache_size = trapsp->cache_size - 2;
  468.       asp = trapsp->asp;
  469.       tp = trapsp->tp;
  470.       pop_trap_frame();
  471.       *--rsp = accu;
  472.       cache_size++;
  473.       Next;
  474.       
  475.     Instruct(POPTRAP):
  476.       if (signal_is_pending) {
  477.         /* We must check here so that if a signal is pending and its
  478.            handler triggers an exception, the exception is trapped
  479.            by the current try...with, not the englobing one. */
  480.         pc--; /* restart the POPTRAP after processing the signal */
  481.         goto process_signal;
  482.       }
  483.       rsp = (value *) tp;
  484.       env = trapsp->env;
  485.       cache_size = trapsp->cache_size - 2;
  486.       asp = trapsp->asp;
  487.       tp = trapsp->tp;
  488.       pop_trap_frame();
  489.       Next;
  490.       
  491.     Instruct(CONSTBYTE):
  492.       accu = *pc++;  Next;
  493.     Instruct(CONSTSHORT):
  494.       accu = s16pc; pc += SHORT; Next;
  495.  
  496.     Instruct(ATOM0):
  497.       accu = Atom(0); Next;
  498.     Instruct(ATOM1):
  499.       accu = Atom(1); Next;
  500.     Instruct(ATOM2):
  501.       accu = Atom(2); Next;
  502.     Instruct(ATOM3):
  503.       accu = Atom(3); Next;
  504.     Instruct(ATOM4):
  505.       accu = Atom(4); Next;
  506.     Instruct(ATOM5):
  507.       accu = Atom(5); Next;
  508.     Instruct(ATOM6):
  509.       accu = Atom(6); Next;
  510.     Instruct(ATOM7):
  511.       accu = Atom(7); Next;
  512.     Instruct(ATOM8):
  513.       accu = Atom(8); Next;
  514.     Instruct(ATOM9):
  515.       accu = Atom(9); Next;
  516.     Instruct(ATOM):
  517.       accu = Atom(*pc++); Next;
  518.       
  519.     Instruct(GETGLOBAL):
  520.       accu = Field(global_data, u16pc);
  521.       pc += SHORT;
  522.       Next;
  523.     Instruct(SETGLOBAL):
  524.       modify(&Field(global_data, u16pc), accu);
  525.       pc += SHORT;
  526.       Next;
  527.       
  528.     Instruct(PUSH):
  529.       *--asp = accu; Next;
  530.     Instruct(POP):
  531.       accu = *asp++; Next;
  532.     Instruct(PUSHMARK):
  533.       *--asp = MARK;
  534.       Next;
  535.       
  536. #define branch() pc += s16pc
  537. #define cond_branch(condition) if (condition) branch(); else pc += 2
  538.  
  539.     Instruct(BRANCH):
  540.       branch(); Next;
  541.     Instruct(BRANCHIF):
  542.       if (Tag_val(accu) != 0) branch(); else pc += SHORT;
  543.       Next;
  544.     Instruct(BRANCHIFNOT):
  545.       if (Tag_val(accu) == 0) branch(); else pc += SHORT;
  546.       Next;
  547.     Instruct(POPBRANCHIFNOT):
  548.       tmp = accu;
  549.       accu = *asp++;
  550.       if (Tag_val(tmp) == 0) branch(); else pc += SHORT;
  551.       Next;
  552.     Instruct(BRANCHIFNEQTAG):
  553.       if (Tag_val(accu) != *pc++) branch(); else pc += SHORT;
  554.       Next;
  555.     Instruct(SWITCH):
  556.       Assert(Long_val(accu) >= 0 && Long_val(accu) < *pc);
  557.       pc++;
  558.       pc += s16(pc + accu - 1);
  559.       Next;
  560.     Instruct(BOOLNOT):
  561.       accu = Atom(Tag_val(accu) == 0); Next;
  562.       
  563.     Instruct(GETFIELD0):
  564.       accu = Field(accu,0); Next;
  565.     Instruct(GETFIELD1):
  566.       accu = Field(accu,1); Next;
  567.     Instruct(GETFIELD2):
  568.       accu = Field(accu,2); Next;
  569.     Instruct(GETFIELD3):
  570.       accu = Field(accu,3); Next;
  571.     Instruct(GETFIELD):
  572.       accu = Field(accu,*pc++); Next;
  573.       
  574.     Instruct(SETFIELD0):
  575.       tmp = 0;
  576.     setfield:
  577.       { value * ptr;
  578.         ptr = &Field(accu, tmp);
  579.         tmp = *asp++;
  580.         Modify(ptr, tmp);
  581.         accu = Atom(0);
  582.       }
  583.       Next;
  584.     Instruct(SETFIELD1):
  585.       tmp = 1;
  586.       goto setfield;
  587.     Instruct(SETFIELD2):
  588.       tmp = 2;
  589.       goto setfield;
  590.     Instruct(SETFIELD3):
  591.       tmp = 3;
  592.       goto setfield;
  593.     Instruct(SETFIELD):
  594.       tmp = *pc++;
  595.       goto setfield;
  596.       
  597.     Instruct(MAKEBLOCK1):
  598.       Alloc_small(tmp, 1, *pc);
  599.       pc++;
  600.       Field(tmp,0) = accu;
  601.       accu = tmp;
  602.       Next;
  603.     Instruct(MAKEBLOCK2):
  604.       Alloc_small(tmp, 2, *pc);
  605.       pc++;
  606.       Field(tmp,0) = accu;
  607.       Field(tmp,1) = *asp++;
  608.       accu = tmp;
  609.       Next;
  610.     Instruct(MAKEBLOCK3):
  611.       Alloc_small(tmp, 3, *pc);
  612.       pc++;
  613.       Field(tmp,0) = accu;
  614.       Field(tmp,1) = *asp++;
  615.       Field(tmp,2) = *asp++;
  616.       accu = tmp;
  617.       Next;
  618.     Instruct(MAKEBLOCK4):
  619.       Alloc_small(tmp, 4, *pc);
  620.       pc++;
  621.       Field(tmp,0) = accu;
  622.       Field(tmp,1) = *asp++;
  623.       Field(tmp,2) = *asp++;
  624.       Field(tmp,3) = *asp++;
  625.       accu = tmp;
  626.       Next;
  627.     Instruct(MAKEBLOCK):
  628.       { header_t hdr;
  629.         mlsize_t size;
  630.     tag_t tag;
  631.     value * to;
  632.     
  633.     hdr = u32pc;
  634.     pc += LONG;
  635.     size = Wosize_hd(hdr);
  636.     tag = Tag_hd(hdr);
  637.         if (size < Max_young_wosize) {
  638.           Alloc_small(tmp, size, tag);
  639.           to = &Field(tmp, 0);
  640.           *to++ = accu;
  641.           for (size--; size > 0; size--) *to++ = *asp++;
  642.           accu = tmp;
  643.         } else {
  644.           Setup_for_gc;
  645.           tmp = alloc_shr (size, tag);
  646.           Restore_after_gc;
  647.           to = &Field(tmp, 0);
  648.           initialize (to++, accu);
  649.           for (size--; size > 0; size--) initialize (to++, *asp++);
  650.           accu = tmp;
  651.         }
  652.     Next;
  653.       }
  654.       
  655.     Instruct(TAGOF):
  656.       accu = Val_long(Tag_val(accu));
  657.       Next;
  658.  
  659.     Instruct(C_CALL1):
  660.       Setup_for_c_call;
  661.       accu = (cprim[u16pc])(accu);
  662.       Restore_after_c_call;
  663.       pc += SHORT;
  664.       Next;
  665.     Instruct(C_CALL2):
  666.       Setup_for_c_call;
  667.       accu = (cprim[u16pc])(accu, asp[0]);
  668.       Restore_after_c_call;
  669.       pc += SHORT;
  670.       asp += 1;
  671.       Next;
  672.     Instruct(C_CALL3):
  673.       Setup_for_c_call;
  674.       accu = (cprim[u16pc])(accu, asp[0], asp[1]);
  675.       Restore_after_c_call;
  676.       pc += SHORT;
  677.       asp += 2;
  678.       Next;
  679.     Instruct(C_CALL4):
  680.       Setup_for_c_call;
  681.       accu = (cprim[u16pc])(accu, asp[0], asp[1], asp[2]);
  682.       Restore_after_c_call;
  683.       pc += SHORT;
  684.       asp += 3;
  685.       Next;
  686.     Instruct(C_CALL5):
  687.       Setup_for_c_call;
  688.       accu = (cprim[u16pc])(accu, asp[0], asp[1], asp[2], asp[3]);
  689.       Restore_after_c_call;
  690.       pc += SHORT;
  691.       asp += 4;
  692.       Next;
  693.     Instruct(C_CALLN):
  694.       { int n = *pc++;
  695.         *--asp = accu;
  696.         Setup_for_c_call;
  697.         accu = (cprim[u16pc])(asp, n);
  698.         Restore_after_c_call;
  699.         pc += SHORT;
  700.         asp += n;
  701.         Next; }
  702.       
  703.     Instruct(NEGINT):
  704.       accu = 2 - accu; Next;
  705.     Instruct(SUCCINT):
  706.       accu += 2; Next;
  707.     Instruct(PREDINT):
  708.       accu -= 2; Next;
  709.     Instruct(ADDINT):
  710.       accu += *asp++ - 1; Next;
  711.     Instruct(SUBINT):
  712.       accu -= *asp++ - 1; Next;
  713.     Instruct(MULINT):
  714.       accu = 1 + (accu >> 1) * (*asp++ - 1); Next;
  715.     Instruct(DIVINT):
  716.       tmp = *asp++ - 1;
  717.       if (tmp == 0) {
  718.         accu = Atom(ZERO_DIVIDE_EXN);
  719.         goto raise;
  720.       }
  721.       accu = Val_long((accu - 1) / tmp);
  722.       Next;
  723.     Instruct(MODINT):
  724.       tmp = *asp++ - 1;
  725.       if (tmp == 0) {
  726.         accu = Atom(ZERO_DIVIDE_EXN);
  727.         goto raise;
  728.       }
  729.       accu = 1 + (accu - 1) % tmp;
  730.       Next;
  731.     Instruct(ANDINT):
  732.       accu &= *asp++; Next;
  733.     Instruct(ORINT):
  734.       accu |= *asp++; Next;
  735.     Instruct(XORINT):
  736.       accu = 1 + (accu ^ *asp++); Next;
  737.     Instruct(SHIFTLEFTINT):
  738.       accu = 1 + ((accu - 1) << Long_val(*asp++)); Next;
  739.     Instruct(SHIFTRIGHTINTSIGNED):
  740.       accu = 1 | ((accu - 1) >> Long_val(*asp++)); Next;
  741.     Instruct(SHIFTRIGHTINTUNSIGNED):
  742.       accu = 1 | ((unsigned long)(accu - 1) >> Long_val(*asp++)); Next;
  743.       
  744. #define inttest(name1,name2,tst)                         \
  745.     Instruct(name1):                                 \
  746.       accu = Atom(accu tst *asp++);                         \
  747.       Next;                                     \
  748.     Instruct(name2):                                 \
  749.       if (accu tst *asp++) { branch(); } else { pc += SHORT; }               \
  750.       Next;
  751.       
  752.       inttest(EQ,BRANCHIFEQ,==);
  753.       inttest(NEQ,BRANCHIFNEQ,!=);
  754.       inttest(LTINT,BRANCHIFLT,<);
  755.       inttest(GTINT,BRANCHIFGT,>);
  756.       inttest(LEINT,BRANCHIFLE,<=);
  757.       inttest(GEINT,BRANCHIFGE,>=);
  758.  
  759.     Instruct(BRANCHINTERVAL):
  760.       { value low_bound, high_bound;
  761.         high_bound = accu;
  762.         low_bound = *asp++;
  763.         accu = *asp++;
  764.         if (accu < low_bound) {
  765.           branch();
  766.           Next;
  767.         }
  768.         pc += SHORT;
  769.         if (accu > high_bound) {
  770.           branch();
  771.           Next;
  772.         } 
  773.         pc += SHORT;
  774.         accu = accu - low_bound + 1;
  775.         Next;
  776.       }
  777.  
  778.     Instruct(INCR):
  779.       Field(accu, 0) += 2; accu = Atom(0); Next;
  780.     Instruct(DECR):
  781.       Field(accu, 0) -= 2; accu = Atom(0); Next;
  782.  
  783.     Instruct(FLOATOP):
  784.       { Alloc_small(tmp, Double_wosize, Double_tag);
  785.     switch(*pc++) {
  786.     case FLOATOFINT: 
  787.       Store_double_val(tmp, (double) Long_val(accu)); break;
  788.     case NEGFLOAT:
  789.       Store_double_val(tmp, -Double_val(accu)); break;
  790.     case ADDFLOAT:
  791.       Store_double_val(tmp, Double_val(accu) + Double_val(*asp++)); break;
  792.     case SUBFLOAT:
  793.       Store_double_val(tmp, Double_val(accu) - Double_val(*asp++)); break;
  794.     case MULFLOAT: 
  795.       Store_double_val(tmp, Double_val(accu) * Double_val(*asp++)); break;
  796.     case DIVFLOAT:
  797.       Store_double_val(tmp, Double_val(accu) / Double_val(*asp++)); break;
  798.     }
  799.     accu = tmp;
  800.     Next;
  801.       }
  802.       
  803.     Instruct(INTOFFLOAT):
  804.       accu = Val_long((long)Double_val(accu)); Next;
  805.       
  806. #define floattest(name, tst)                             \
  807.     Instruct(name):                                 \
  808.       accu = Atom(Double_val(accu) tst Double_val(*asp++));             \
  809.       Next;
  810.       
  811.       floattest(EQFLOAT,==);
  812.       floattest(NEQFLOAT,!=);
  813.       floattest(LTFLOAT,<);
  814.       floattest(GTFLOAT,>);
  815.       floattest(LEFLOAT,<=);
  816.       floattest(GEFLOAT,>=);
  817.       
  818.     Instruct(STRINGLENGTH):
  819.       accu = Val_long(string_length(accu));
  820.       Next;
  821.     Instruct(GETSTRINGCHAR):
  822.       accu = Val_long(Byte_u(accu, Long_val(*asp++)));
  823.       Next;
  824.     Instruct(SETSTRINGCHAR):
  825.       Byte_u(accu, Long_val(asp[0])) = Long_val(asp[1]);
  826.       accu = Atom(0);
  827.       asp += 2;
  828.       Next;
  829.  
  830. #define stringtest(name, tst)                                                \
  831.     Instruct(name):                                                          \
  832.       accu = Atom(compare_strings(accu, *asp++) tst Val_long(0));            \
  833.       Next;
  834.       
  835.       stringtest(EQSTRING,==);
  836.       stringtest(NEQSTRING,!=);
  837.       stringtest(LTSTRING,<);
  838.       stringtest(GTSTRING,>);
  839.       stringtest(LESTRING,<=);
  840.       stringtest(GESTRING, >=);
  841.  
  842.     Instruct(MAKEVECTOR):
  843.       { mlsize_t size = Long_val(accu);
  844.         if (size == 0)
  845.           accu = Atom(0);
  846.         else if (size < Max_young_wosize){
  847.       Alloc_small (accu, size, 0);
  848.       do {size--; Field (accu, size) = *asp;} while (size != 0);
  849.     }else if (Is_block (*asp) && Is_young (*asp)){
  850.       Setup_for_gc;
  851.       minor_collection ();
  852.       tmp = alloc_shr (size, 0);
  853.       Restore_after_gc;
  854.           accu = tmp;
  855.       do {size--; Field (accu, size) = *asp;} while (size != 0);
  856.     }else{
  857.       Setup_for_gc;
  858.       tmp = alloc_shr (size, 0);
  859.       Restore_after_gc;
  860.           accu = tmp;
  861.       do {size--; initialize(&Field(accu, size), *asp);} while (size != 0);
  862.     }
  863.         asp++;
  864.     Next;
  865.       }
  866.     Instruct(VECTLENGTH):
  867.       accu = Val_long(Wosize_val(accu));
  868.       Next;
  869.     Instruct(GETVECTITEM):
  870.       accu = Field(accu, Long_val(*asp++));
  871.       Next;
  872.     Instruct(SETVECTITEM):
  873.       tmp = Long_val(*asp++);
  874.       goto setfield;
  875.  
  876. #ifdef DEBUG
  877.     default:
  878.       fatal_error("unknown opcode");
  879. #endif
  880.  
  881. #ifndef DIRECT_JUMP
  882.     }
  883.   }
  884. #endif
  885. }
  886.  
  887. static unsigned char callback_code [] = { POP, APPLY, STOP };
  888.  
  889. value callback(closure, argument)
  890.      value closure, argument;
  891. {
  892.   *--extern_asp = MARK;
  893.   *--extern_asp = argument;
  894.   *--extern_asp = closure;
  895.   return interprete(callback_code);
  896. }
  897.